unit wbFontUtils;

interface

uses Windows, Classes, SysUtils;

type

  TNewTextMetricEx = packed record
    NewTextMetric: TNewTextMetric;
    FontSignature: TFontSignature
  end;

  TCharSetRec = packed record
    Name: string;
    ID: Integer
  end;


const
  NumCharSets = 19;

  CharSets: array[0..NumCharSets - 1] of TCharSetRec = (
     (Name: 'ANSI_CHARSET'; ID: 0),
     (Name: 'DEFAULT_CHARSET'; ID: 1),
     (Name: 'SYMBOL_CHARSET'; ID: 2),
     (Name: 'SHIFTJIS_CHARSET'; ID: $80),
     (Name: 'HANGEUL_CHARSET'; ID: 129),
     (Name: 'GB2312_CHARSET'; ID: 134),
     (Name: 'CHINESEBIG5_CHARSET'; ID: 136),
     (Name: 'OEM_CHARSET'; ID: 255),
     (Name: 'JOHAB_CHARSET'; ID: 130),
     (Name: 'HEBREW_CHARSET'; ID: 177),
     (Name: 'ARABIC_CHARSET'; ID: 178),
     (Name: 'GREEK_CHARSET'; ID: 161),
     (Name: 'TURKISH_CHARSET'; ID: 162),
     (Name: 'VIETNAMESE_CHARSET'; ID: 163),
     (Name: 'THAI_CHARSET'; ID: 222),
     (Name: 'EASTEUROPE_CHARSET'; ID: 238),
     (Name: 'RUSSIAN_CHARSET'; ID: 204),
     (Name: 'MAC_CHARSET'; ID: 77),
     (Name: 'BALTIC_CHARSET'; ID: 186));


procedure GetAvailableCharSets(const FaceName: string; CharSets: TStrings);
procedure GetAvailableFonts(var Fonts: TStrings);

implementation

uses Printers;


function EnumProc(const EnumLogFontEx: TEnumLogFontEx;
  const NewTextMetricEx: TNewTextMetricEx;
  FontType: Integer;
  Strings: TStrings): Integer; stdcall;
var
  I: Integer;
  ID: Integer;
  S: string;
begin
  ID := EnumLogFontEx.elfLogFont.lfCharSet;
  S  := Format('Unknown charset %d', [ID]);
  for I := 0 to NumCharSets - 1 do begin
    if CharSets[I].ID = ID then
    begin
      S := CharSets[I].Name;
      Strings.Add(S);
      //Break;
    end;
  end;
  Result := 1
end;

procedure GetAvailableCharSets(const FaceName: string; CharSets: TStrings);
var
  DC: THandle;
  AFont: TLogFont;
begin
  DC := GetDC(GetDesktopWindow);

  if DC <> 0 then
  try
    FillChar(AFont, SizeOf(AFont), 0);
    Move(FaceName[1], AFont.lfFaceName, Length(FaceName));

    AFont.lfCharSet := DEFAULT_CHARSET;
    AFont.lfItalic := 0;
    AFont.lfUnderline := 0;
    AFont.lfStrikeOut := 0;

    EnumFontFamiliesEx(DC, AFont, @EnumProc, lParam(CharSets), 0);
  finally
    ReleaseDC(GetDesktopWindow, DC)
  end
end;

{
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Memo1.Clear;
   GetAvailableCharSets('Arial Narrow Bold', Memo1.Lines);
 end;



var
  i, index: Integer;
  sl: TStringList;
begin
  StringTreeLang.NodeDataSize := SizeOf(TLangData);

  try
    sl := TStringList.Create;
    GetAvailableFonts( TStrings(sl) );
    sl.Sort;
    cbFontList.Items.Assign(sl);
    cbFontList.ItemIndex := cbFontList.Items.IndexOf(StringTreeLang.Font.Name);
  finally
    sl.Free;
  end;


  cbCharsetList.Items.Clear;
  GetAvailableCharSets(StringTreeLang.Font.Name, cbCharsetList.Items);

  for i := 1 to cbCharsetList.Items.Count -1
  do begin
    if (StringTreeLang.Font.Charset = CharSets[i].ID) then
      cbCharsetList.ItemIndex := i;
  end;

end;


procedure TfmMain.cbFontListChange(Sender: TObject);
begin
  StringTreeLang.Font.Name := cbFontList.Text;

  cbCharsetList.Items.Clear;
  GetAvailableCharSets(StringTreeLang.Font.Name, cbCharsetList.Items);
  StringTreeLang.Font.Charset :=  CharSets[cbCharsetList.ItemIndex].ID;
end;

}










function EnumFontFamilyProc(var lf: TLogFont;
  var tm: TNewTextMetric;
  FontType: integer;
  var sl: TStringList): integer
{$IFDEF WIN32} stdcall;
{$ELSE}; export;
{$ENDIF}
begin
  sl.Add(StrPas(@lf.lfFaceName) + #32 + IntToStr(lf.lfHeight));
  result := 1;
end;

function EnumFontFamiliesProc(var lf: TLogFont;
  var tm: TNewTextMetric;
  FontType: integer;
  var sl: TStringList): integer
{$IFDEF WIN32} stdcall;
{$ELSE}; export;
{$ENDIF}
begin
   sl.Add(StrPas(@lf.lfFaceName));
{
  if FontType = TRUETYPE_FONTTYPE then
  begin
    sl.Add(StrPas(@lf.lfFaceName) + #32 + 'All Sizes');
  end
  else
    EnumFontFamilies(Printer.Handle,
      @lf.lfFaceName,
      @EnumFontFamilyProc,
      LongInt(@sl));
}
  result := 1;
end;

procedure GetAvailableFonts(var Fonts: TStrings);
var
  DC: THandle;
begin
  DC := GetDC(GetDesktopWindow);
  EnumFontFamilies(DC, //Printer.Handle
      nil,
      @EnumFontFamiliesProc,
      LongInt(@Fonts));
end;



end.
